home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-11
/
mpack.zip
/
MPACK.PRG
< prev
Wrap
Text File
|
1993-01-04
|
4KB
|
163 lines
* MemoPak3 is a Clipper UDF to pack the DBT associated with a DBF.
* This function requires the name of the DBF and a name to use for the
* temporary index that will be created. It only works on files with 1
* memo field and will lose and or corrupt all of the data associated
* with all memo fields other than the first. The main advantage of
* this function over the more standard COPY TO; DELETE; RENAME, syntax,
* is that it uses less disk space than the COPY TO method
* This version even seems to have the advantage
* of being faster than the COPY TO method.
*
* Ira Emus
* irae BIX
* Sep. 18, 1988
* memopak3("filename",'indxname')
FUNCTION memopak3
PARAMETER file2pack,ntxname
dbfname = TRIM(file2pack)+".dbf"
dbtname = TRIM(file2pack)+".dbt"
pkoffset = 0
pkname = getmemoname(dbfname,@pkoffset)
memo2chr(dbfname,pkoffset)
SELE 0
USE (file2pack) ALIAS f2pack
INDEX ON &pkname TO &ntxname
*
* Find the first memofield
*
SET SOFTSEEK ON
SEEK " 1"
dbtnum = FOPEN(dbtname,2)
*
* cur_pos is the current offset into the .dbt file where the next memofield
* will be written. The actual offset will be cur_pos * 512.
*
cur_pos = 1
buffer1 = space(512)
writeit = 512
DO WHILE !EOF()
*
* The location of the memofield attached to the current record is
* determined by looking at the contents of the memo field in the
* database and multipling by 512
where = (512*val(&pkname))
counter = 1
do while .T.
FSEEK(dbtnum,where,0)
fread(dbtnum,@buffer1,512)
FSEEK(dbtnum,writeit,0)
FWRITE(dbtnum,@buffer1,512)
writeit = writeit+512
if chr(26) $ buffer1
exit
endif
where = where+512
counter=counter+1
ENDDO
REPLACE &pkname WITH str(cur_pos,10)
cur_pos = cur_pos + counter
SKIP
ENDDO
CLOSE DATA
cur_pos = cur_pos+1
FWRITE(dbtnum,'',0)
FSEEK(dbtnum,0,0)
FWRITE(L2BIN(cur_pos))
FCLOSE(dbtnum)
chr2memo(dbfname,pkoffset)
RETURN .T.
FUNCTION getmemoname
* This function will return the name of the first memo field, or an empty
* string if there is no memo field found and will put the offset into
* the file of the field type identifier into the passed parameter offset.
* The parameter offset MUST be passed by reference and
* must have been previously declared to a numeric
*
* fieldname = getmemoname(filename,@offset)
*
PARAMETER filename,offset
handle = FOPEN(filename,2)
test = FREADSTR(handle,1)
IF "â" = test
FSEEK(handle,8,0)
headlen = SPACE(2)
FREAD(handle,@headlen,2)
headlen = BIN2W(headlen)
offset = 43
FSEEK(handle,offset,0)
test = FREADSTR(handle,1)
DO WHILE test # 'M' .AND. headlen > offset
offset = offset+ 32
FSEEK(handle,offset,0)
test = FREADSTR(handle,1)
ENDDO
IF test = "M"
FSEEK(handle,offset-11,0)
fieldname = space(10)
FREAD(handle,@fieldname,10)
FCLOSE(handle)
RETURN substr(fieldname,1,at(chr(0),fieldname)-1)
ENDIF
ENDIF
RETURN ""
FUNCTION memo2chr
* This function given an offset and a filename will change the specified
* location to a "C" and change the header to indicate NO associated DBT.
* The offset should have been obtained with getmemoname.
*
* memo2chr(filename,offset)
*
PARAMETER filename,offset
handle = FOPEN(filename,2)
test = FREADSTR(handle,1)
IF "â" = test
FSEEK(handle,0,0)
FWRITE(handle,"")
FSEEK(handle,offset,0)
FWRITE(handle,"C")
FCLOSE(handle)
RETURN .T.
ENDIF
RETURN .F.
FUNCTION chr2memo
* This function given an offset and a filename will change the specified
* location to a "M" and change the header to indicate that there is an
* associated DBT.
* The offset should have been obtained with getmemoname.
*
* chr2memo(filename,offset)
*
PARAMETER filename,offset
handle = FOPEN(filename,2)
FWRITE(handle,"â")
FSEEK(handle,offset,0)
test = FREADSTR(handle,1)
IF test = "C"
FSEEK(handle,offset,0)
FWRITE(handle,"M")
FERROR()
FCLOSE(handle)
RETURN offset
ENDIF
RETURN -1